#lang racket


(require "../base/main.rkt"
         "../backends/main.rkt"
         "../ast/main.rkt")
(require (only-in "../constructors/main.rkt"
                  generic-evaluate
                  generic-evaluate-toplevel))
(require "../geometry/main.rkt"
         "../parametrization/main.rkt")

(require "rh-global.rkt"
         (prefix-in mar: "rh-marshal.rkt"))

(provide load-rhino-backend)


; exception

(define-struct (backend-exn exn:fail) ())

(define (raise-backend-exn msg)
  (raise (make-backend-exn msg (current-continuation-marks))))

(define (align-type-msg type)
  (format "Unhandled align type, given ~A" type))

(define (circle-msg type)
  (format "A circle can only be a line or surface, not ~A" type))

(define line-msg
  "Warning: Line: Rhino cannot make an open curve/polycurve with equal start and end coord; a close curve will be created instead")


; defer

(define-struct defer ())

(define-struct (defer-intersect defer)
  (shape1 shape2))

(define-struct (defer-subtract defer)
  (shape1 shape2))

(define-struct (defer-union defer)
  (shape1 shape2))

(define (list<-defer defer)
  (cond ((defer-intersect? defer)
         (list
          (defer-intersect-shape1 defer)
          (defer-intersect-shape2 defer)))
        ((defer-subtract? defer)
         (list
          (defer-subtract-shape1 defer)
          (defer-subtract-shape2 defer)))
        ((defer-union? defer)
         (list
          (defer-union-shape1 defer)
          (defer-union-shape2 defer)))
        (else
         (exn:fail:contract))))

(define (defer-dispatch shape1 shape2 shape-shape shape-defer defer-shape defer-defer)
  (cond ((and (defer? shape1) (defer? shape2)) defer-defer)
        ((defer? shape1) defer-shape)
        ((defer? shape2) shape-defer)
        (else shape-shape)))

(define (defer-subdispatch defer defer-intersect defer-subtract defer-union)
  (cond ((defer-intersect? defer) (defer-intersect))
        ((defer-subtract? defer) (defer-subtract))
        ((defer-union? defer) (defer-union))))

(define (delete-defer-shapes defer)
  (if (shape? defer)
      (delete defer)
      (map delete-defer-shapes (list<-defer defer))))

(define (replace-defer defer)
  (cond ((defer-intersect? defer)
         (error 'replace-defer "Not implemented"))
        ((defer-subtract? defer)
         (delete-defer-shapes (defer-subtract-shape2 defer))
         (list (defer-subtract-shape1 defer)))
        ((defer-union? defer)
         (append
          (replace-defer (defer-union-shape1 defer))
          (replace-defer (defer-union-shape2 defer))))
        (else
         (list defer))))

(define (replace-defers shapes)
  (if (rhino-replace-defer?)
      (if (list? shapes)
          (map-append-tree replace-defer shapes)
          shapes)
      shapes))

; /defer


; points

(define (point c)
  (mar:add-point c))


; lines

(define (arc angle radius)
  (mar:add-arc (mar:world-xy-plane) radius (degrees<-radians angle)))

(define (elliptical-arc angle x-radius y-radius)
  (scale (xyz x-radius y-radius 1) (arc angle 1)))

(define (ellipse x-radius y-radius)
  (mar:add-ellipse (mar:world-xy-plane) x-radius y-radius))

(define (line closed? coords)
  (define (open-line)
    (when (eq-c (first coords) (last coords))
      (displayln line-msg))
    (mar:add-polyline coords))
  
  (define (closed-line)
    (let ((shape (mar:add-polyline coords)))
      (cond ((mar:is-curve-closed? shape)
             shape)
            ((mar:is-curve-closable? shape)
             (mar:close-curve shape))
            (else
             (delete shape)
             (mar:add-polyline (append-first coords))))))
  
  (if closed?
      (closed-line)
      (open-line)))

(define (spline closed? cs type)
  (match type
    ((auto-spline-type)
     (when closed?
       (error 'spline "Only open splines are implemented in Rhino backend"))
     (mar:add-interp-curve cs))
    ((tangent-spline-type begin-tangent end-tangent)
     (error 'spline "Only simple splines are implemented in Rhino backend"))))


; surfaces

; surface

(define (surface-msg shapes)
  (format "Surface: parameter (shapes) must be 1 closed curve or a list of 2, 3 or 4 coords or lines, given ~A" shapes))

(define (surface-from-list shapes)
  (cond
    ((andmap coord? shapes)
     (mar:add-surface-coords shapes))
    ((andmap mar:is-curve? shapes)
     (mar:add-edge-surface shapes))
    (else
     (error 'surface (surface-msg shapes)))))

(define (surface shapes)
  (cond ((list? shapes)
         (surface-from-list shapes))
        ((mar:is-curve-closed? shapes)
         (mar:add-planar-surface shapes))
        ; edit: hack or correct? perhaps introduce the concept of polysurface
        (else
         (mar:add-edge-surface (list shapes)))))

; /surface


; solids

(define (box width length height)
  (mar:add-box (flatten (map list<-coord (box-corners width length height)))))

(define (cone radius height)
  (mar:add-cone
   u0
   (mult-c uz height)
   radius
   true))

(define (cone-frustrum base-radius top-radius height)
  (define (normal-cone base-radius top-radius height)
    (let ((top-height 
           (/
            (* height top-radius)
            (- base-radius top-radius))))
      (subtract
       (cone base-radius (+ height top-height))
       (move
        (mult-c uz (+ height (/ top-height 2)))
        (box (+ (*2 top-height) 1) (+ (*2 top-height) 1) top-height)))))
  
  (define (inverted-cone base-radius top-radius height)
    (rotate pi ux
            (move
             (mult-c uz (- height))
             (normal-cone base-radius top-radius height))))
  
  (if (> top-radius base-radius)
      (inverted-cone top-radius base-radius height)
      (normal-cone base-radius top-radius height)))

(define (cylinder radius height)
  (mar:add-cylinder u0 (mult-c uz height) radius true))

(define (pyramid width sides height)
  (if (= sides 4)
      (mar:join-surfaces
       (list
        (mar:add-planar-surface (rectangle width width))
        (mar:extrude-curve-coord
         (rectangle width width)
         (mult-c uz height)))
       #t)
      (error 'pyramid "Only 4-sided pyramids are implemented")))

(define (sphere radius)
  (mar:add-sphere u0 radius))


; generic shapes

(define (circle type radius)
  (match type
    ((struct line-primitive-type ()) (mar:add-circle (mar:world-xy-plane) radius))
    ((struct surface-primitive-type ()) (mar:add-planar-surface (circle (line-primitive-type) radius)))
    (else (raise-backend-exn (circle-msg type)))))

(define (rectangle width length)
  (line #t (rectangle-coords width length)))


; transformations

(define (extrude length shape)
  (if (mar:is-curve? shape)
      (mar:extrude-curve-straight shape u0 (+z u0 length))
      (error 'extrude "Implemented only for curves")))


; intersect

(define (rh-intersect shape1 shape2)
  (cond ((and (mar:is-surface? shape1) (mar:is-surface? shape2))
         (mar:intersect-breps shape1 shape2))
        (else
         (mar:boolean-intersection shape1 shape2 #t))))


; A /\ B
(define (intersect.shape-shape shape1 shape2)
  (rh-intersect shape1 shape2))

; A /\ d(B ? C)
(define (intersect.shape-defer shape defer)
  (error 'intersect.shape-defer "Not implemented"))

; d(A ? B) /\ C
(define (intersect.defer-shape defer shape)
  ; d(A /\ B) /\ C
  (define (intersect.defer-intersect-shape a b c)
    (let ((result (rh-intersect (rh-intersect a c) b)))
      (if (void? result)
          (intersect (rh-intersect b c) a)
          result)))
  
  ; d(A - B) /\ C
  (define (intersect.defer-subtract-shape a b c)
    (error 'intersect.defer-subtract-shape "Not implemeneted"))
  
  ; d(A U B) /\ C
  (define (intersect.defer-union-shape a b c)
    (error 'intersect.defer-union-shape "Not implemented"))
  
  (match defer
    ((struct defer-intersect (a b))
     (intersect.defer-intersect-shape a b shape))
    ((struct defer-subtract (a b))
     (intersect.defer-subtract-shape a b shape))
    ((struct defer-union (a b))
     (intersect.defer-union-shape a b shape))))

; d(A ? B) /\ d(C ? D)
(define (intersect.defer-defer defer1 defer2)
  (error 'intersect.defer-defer "Not implemented"))

(define (defer-dispatch-intersect shape1 shape2)
  (defer-dispatch
    shape1
    shape2
    intersect.shape-shape
    intersect.shape-defer
    intersect.defer-shape
    intersect.defer-defer))

(define (intersect shape1 shape2)
  (let ((result ((defer-dispatch-intersect shape1 shape2) shape1 shape2)))
    (cond ((void? result)
           (defer-intersect shape1 shape2))
          (else
           result))))

; /intersect


(define (join shapes)
  (mar:join-curves shapes #t))


; loft

(define (loft-curves shapes closed?)
  (mar:add-loft-surface shapes closed?))

(define (loft-borders shapes)
  (map
   (λ (shape)
     (if (mar:is-surface? shape)
         (join (mar:duplicate-surface-border shape))
         shape))
   shapes))

;(define (loft-surfaces shapes closed? surfaces)
;  (displayln "Loft:")
;  (displayln (format "shapes (~A) ~A" (length shapes) shapes))
;  (displayln (format "surfaces (~A) ~A" (length surfaces) surfaces))
;  (displayln "----------------------")
;  (let* ((lofted-curves (loft-curves (loft-borders shapes) closed?))
;         (lofted-surfaces (cons lofted-curves surfaces)))
;    (with-handlers ((exn?
;                     (λ (e)
;                       (displayln "Loft warning: surfaces may not appear in the lofted shape")
;                       ;(map delete surfaces)
;                       lofted-curves)))
;      (reduce (λ (s ss) (mar:join-surfaces (cons s ss) #t)) lofted-surfaces))))

; edit: wait for McNeel's email
(define (loft-surfaces shapes closed? surfaces)
  (map delete surfaces)
  (mar:cap-planar-holes (loft-curves (loft-borders shapes) closed?)))

(define (loft closed? shapes)
  (let ((surfaces (map mar:copy (filter mar:is-surface? shapes))))
    (if (empty? surfaces)
        (loft-curves shapes closed?)
        (loft-surfaces shapes closed? surfaces))))

; /loft


(define (move position shape)
  (if (eq-c position u0)
      shape
      (mar:move shape position)))

(define (rotate angle normal shape)
  (mar:rotate
   shape
   u0
   (degrees<-radians angle)
   normal
   false))

(define (scale size shape)
  (mar:scale shape u0 size false))

; subtract

(define (rh-subtract shape1 shape2)
  (mar:boolean-difference shape1 shape2 #t))


; A - B
(define (subtract.shape-shape shape1 shape2)
  (rh-subtract shape1 shape2))

; A - d(B ? C)
(define (subtract.shape-defer shape defer)
  (error 'subtract.shape-defer "Not implemented"))

; d(A ? B) - C
(define (subtract.defer-shape defer shape)
  ; d(A /\ B) - C
  (define (subtract.defer-intersect-shape a b c)
    (error 'subtract.defer-intersect-shape "Not implemented"))
  
  ; d(A - B) - C
  (define (subtract.defer-subtract-shape a b c)
    (let ((result (subtract a c)))
      (if (defer-subtract? result)
          (void)
          (subtract result b))))
  
  ; d(A U B) - C
  (define (subtract.defer-union-shape a b c)
    (error 'subtract.defer-union-shape "Not implemented"))
  
  (match defer
    ((struct defer-intersect (a b))
     (subtract.defer-intersect-shape a b shape))
    ((struct defer-subtract (a b))
     (subtract.defer-subtract-shape a b shape))
    ((struct defer-union (a b))
     (subtract.defer-union-shape a b shape))))

; d(A ? B) - d(C ? D)
(define (subtract.defer-defer defer1 defer2)
  (error 'subtract.defer-defer "Not implemented"))

(define (defer-dispatch-subtract shape1 shape2)
  (defer-dispatch
    shape1
    shape2
    subtract.shape-shape
    subtract.shape-defer
    subtract.defer-shape
    subtract.defer-defer))

; edit: replace void with an exception
(define (subtract shape1 shape2)
  (let ((result ((defer-dispatch-subtract shape1 shape2) shape1 shape2)))
    (cond ((void? result)
           (defer-subtract shape1 shape2))
          (else
           result))))

; /subtract

; union

(define (rh-union shape1 shape2)
  (mar:boolean-union shape1 shape2 #t))


; A U B
(define (union.shape-shape shape1 shape2)
  (let ((val (rh-union shape1 shape2)))
    (if (void? val)
        (defer-union shape1 shape2)
        val)))

; A U d(B ? C)
(define (union.shape-defer shape defer)
  (union.defer-shape defer shape))

; d(A ? B) U C
(define (union.defer-shape defer shape)
  ; d(A /\ B) U C
  (define (union.defer-intersect-shape a b c)
    (error 'union.defer-intersect-shape "Not implemented"))
  
  ; d(A - B) U C
  (define (union.defer-subtract-shape a b c)
    (error 'union.defer-subtract-shape "Not implemented"))
  
  ; d(A U B) U C
  ; = (A U C) U B
  ; = (B U C) U A
  (define (union.defer-union-shape a b c)
    (define (union1 a b c)
      (let ((val1 (union a c)))
        (if (defer-union? val1)
            val1
            (union val1 b))))
    
    (define (union2 a b c)
      (let ((val1 (union b c)))
        (if (defer-union? val1)
            val1
            (union val1 a))))
    
    (let ((val1 (union1 a b c)))
      (if (defer-union? val1)
          (let ((val2 (union2 a b c)))
            (if (defer-union? val2)
                (defer-union (mar:join-shapes a b) c)
                val2))
          val1)))
  
  (match defer
    ((struct defer-intersect (a b))
     (union.defer-intersect-shape a b shape))
    ((struct defer-subtract (a b))
     (union.defer-subtract-shape a b shape))
    ((struct defer-union (a b))
     (union.defer-union-shape a b shape))))

; d(A ? B) U d(C ? D)
(define (union.defer-defer defer1 defer2)
  (error 'union.defer-defer "Not implemented"))

(define (dispatch-defer-union shape1 shape2)
  (defer-dispatch
    shape1
    shape2
    union.shape-shape
    union.shape-defer
    union.defer-shape
    union.defer-defer))

(define (union shape1 shape2)
  ((dispatch-defer-union shape1 shape2) shape1 shape2))

; /union


(define (thicken distance shape)
  ;  (let ((s1 (mar:copy shape))
  ;        (s2 (mar:offset-surface shape distance)))
  ;    (let ((s1-border (mar:duplicate-surface-border s1))
  ;          (s2-border (mar:duplicate-surface-border s2)))
  ;      (list
  ;       (surface s1)
  ;       (surface s2)
  ;       (mar:add-loft-surface (list s1-border s2-border) #f)))))
  (mar:offset-surface-solid shape distance))


; lang

(define (align type shape)
  (define (align-shape-center shape)
    (let ((bb (mar:object-bounding-box shape)))
      (move (symmetric (bbox-center bb)) shape)))
  
  (define (align-shape bb-fn xyz-fn shape)
    (let* ((bb (mar:object-bounding-box shape))
           (p (bb-fn bb)))
      (move (xyz-fn (symmetric p) 0 0) shape)))
  
  (match type
    ((center-align-type) (align-shape-center shape))
    ((x-pos-align-type) (align-shape bbox-x-pos yz shape))
    ((x-neg-align-type) (align-shape bbox-x-neg yz shape))
    ((y-pos-align-type) (align-shape bbox-y-pos xz shape))
    ((y-neg-align-type) (align-shape bbox-y-neg xz shape))
    ((z-pos-align-type) (align-shape bbox-z-pos xy shape))
    ((z-neg-align-type) (align-shape bbox-z-neg xy shape))
    (else
     (raise-backend-exn (align-type-msg align)))))

(define (bbox shape)
  (begin0
    (mar:object-bounding-box shape)
    (delete shape)))


; on

; edit: duplicated from ac-backend.rkt
(define (on-shape corner-fn bbox-fn shape1 shape2)
  (let* ((shape1-bb (mar:object-bounding-box shape1))
         (shape2-bb (mar:object-bounding-box shape2))
         (corner (corner-fn shape2-bb))
         (center (bbox-fn shape1-bb corner)))
    (mar:join-shapes
     (mar:move shape1 (bbox-center shape1-bb) center)
     shape2)))

(define (on type shapes)
  (match type
    ((x-pos-on-type) (reducer (cλ on-shape bbox-x-pos bbox-center<-left) shapes))
    ((x-neg-on-type) (reducer (cλ on-shape bbox-x-neg bbox-center<-right) shapes))
    ((y-pos-on-type) (reducer (cλ on-shape bbox-y-pos bbox-center<-front) shapes))
    ((y-neg-on-type) (reducer (cλ on-shape bbox-y-neg bbox-center<-back) shapes))
    ((z-pos-on-type) (reducer (cλ on-shape bbox-z-pos bbox-center<-bottom) shapes))
    ((z-neg-on-type) (reducer (cλ on-shape bbox-z-neg bbox-center<-top) shapes))))

; /on


; par

(define (par-circle shape)
  (let ((center (mar:circle-center shape))
        (normal (mar:circle-normal shape))
        (radius (mar:circle-radius shape)))
    (let ((translation
           (apply m.translate (list<-coord center)))
          (rotation
           (m-rotate (p<\p uz normal (cross-c uz normal)) (cross-c uz normal))))
      (make-transformation-parametric
       (make-transformation-parametric
        (make-circle-curve radius)
        rotation)
       translation))))

(define (par shape)
  (finally
   (cond ((circle? shape)
          (par-circle shape))
         (else
          (error 'par "Unhandled par type")))
   (λ () (delete shape))))

; /par


; properties

(define curve-begin-coord mar:curve-begin-coord)
(define curve-end-coord mar:curve-end-coord)

(define surface-curvature mar:surface-curvature)
(define surface-domain mar:surface-domain)


; cad

; edit: optimize with node? similarly to AutoCAD
(define (begin-draw exp)
  (enable-redraw #f))

(define (delete-shape shape)
  (mar:delete shape))

; edit: optimize with node? similarly to AutoCAD
(define (end-draw exp)
  (enable-redraw #t))

(define (get-shapes)
  (mar:get-all))

(define (render-shape width height path)
  (mar:render width height path))

(define (view type)
  (match type
    ((auto-view-type)
     (error 'view "Not implemented"))
    ((manual-view-type center target projection-type lens)
     (let ((perspective (match projection-type
                          ((ortho-projection-type) mar:view-projection-mode-parallel)
                          ((perspective-projection-type) mar:view-projection-mode-perspective))))
       (mar:view center target perspective lens)))))


; rhino

(define circle? mar:is-circle?)
(define get-circle-center mar:circle-center)
(define get-circle-normal mar:circle-normal)
(define get-circle-radius mar:circle-radius)

(define copy mar:copy)
(define delete mar:delete)
(define enable-redraw mar:enable-redraw)
(define delete-all-objects mar:delete-all)
(define get-object mar:get-object)
(define is-object? mar:is-object?)


; backend

(define-backend rhino-backend
  ((evaluate expr) #f)
  ((evaluate-toplevel expr) #f)
  
  ; points
  
  ((point c) (point c))

  
  ; lines
  
  ((arc angle radius) (arc angle radius))
  ((elliptical-arc angle x-radius y-radius) (elliptical-arc angle x-radius y-radius))
  ((ellipse x-radius y-radius) (ellipse x-radius y-radius))
  ((line closed? coords) (line closed? coords))
  ((nurbs-curve controls knots) (error 'nurbs-curve "Not implemented"))
  ((spline closed? cs type) (spline closed? cs type))
  
  
  ; surfaces
  
  ((donut inner-radius outer-radius) (error 'donut "Not implemented"))
  ((ngon width sides) (error 'ngon "Not implemented"))
  ((nurbs-surface controls u-knots v-knots) (error 'nurbs-surface "Not implemented"))
  ((star width sides stride) (error 'star "Not implemented"))
  ((surface shapes) (surface shapes))
  
  
  ; solids
  
  ((box width length height) (box width length height))
  ((cone radius height) (cone radius height))
  ((cone-frustrum base-radius top-radius height) (cone-frustrum base-radius top-radius height))
  ((cylinder radius height) (cylinder radius height))
  ((pyramid width sides height) (pyramid width sides height))
  ((sphere radius) (sphere radius))
  
  
  ; generic shapes
  
  ((circle type radius) (circle type radius))
  ((rectangle width length) (rectangle width length))
  
  
  ; transformations
  
  ((extrude length shape) (extrude length shape))
  ((intersect shape1 shape2) (intersect shape1 shape2))
  ((join shapes) (join shapes))
  ((loft closed? shapes) (loft closed? shapes))
  ((move position shape) (move position shape))
  ((offset distance shape) (error 'offset "Not implemented"))
  ((rotate angle normal shape) (rotate angle normal shape))
  ((scale size shape) (scale size shape))
  ((subtract shape1 shape2) (subtract shape1 shape2))
  ((sweep path shape) (error 'sweep "Not implemented"))
  ((thicken distance shape) (thicken distance shape))
  ((union shape1 shape2) (union shape1 shape2))
  
  
  ; lang
  
  ((align type shape) (align type shape))
  ((bbox shape) (bbox shape))
  ((on type shapes) (on type shapes))
  ((par shape) (par shape))
  
  
  ; properties
  
  ((curve-begin-coord shape) (curve-begin-coord shape))
  ((curve-end-coord shape) (curve-end-coord shape))
  
  ((surface-curvature shape) (surface-curvature shape))
  ((surface-domain shape) (surface-domain shape))
  
  
  ; cad
  
  ((begin-draw exp) (begin-draw exp))
  ((begin-undo-mark) (error 'begin-undo-mark "Not implemented"))
  ((delete-shape shape) (delete-shape shape))
  ((end-draw exp) (end-draw exp))
  ((end-undo-mark) (error 'end-undo-mark "Not implemented"))
  ((get-shapes) (get-shapes))
  ((render-shape width height path) (render-shape width height path))
  ((undo) (error 'undo "Not implemented"))
  ((view type) (view type)))

(define (load-rhino-backend)
  (mar:load-rhino-marshall)
  (letrec ((backend
            (make-rhino-backend
             #:evaluate (λ (expr) (replace-defers (generic-evaluate backend expr)))
             #:evaluate-toplevel (λ (expr) (replace-defers (generic-evaluate-toplevel backend expr))))))
    (delete-all-objects)
    backend))